;;;; 2008-06-22 21:18:22
; Author: Trystan A Larey-Williams

(in-package :neural-net)

; The design strategy from this NN model was derived from "The Cambridge Handbook of
; Computational Psychology." It outlines the following general properties of a neural
; network.

; 1. Processing Unit (implemented by the neuron and axon classes)
; 2. a(t) the activation state' of a unit at time t (the activation-state slot of class neuron)
; 3. Wij, a given connection strength or weight (the weight slot of the axon class)
; 4. A propagation function, typically of the form i = sum( Wij * aj ) (the generic function 'propagation')
; 5. An activation function (the generic function 'activation')
; 6. Learning rule or connectivity modification function (the generic function 'learning')
; 7. Mapping functions from NN input and output layers to problem domain for (implemented by package user)

; In implementing the processing units and the propagation and activation methods and classes 
; and generic methods, new propagation and activation variants can easilly be "plugged in" and
; experimented upon. 


(defclass neuron ()
  ((outgoing-axons :type list :accessor outgoing-axons :initform '())
   (learning-rate :type number :accessor learning-rate :initform 0.01)
   (incoming-axons :type list :accessor incoming-axons :initform '())
   (activation-state :type number :accessor activation-state :initform 0)
   (previous-activation :type number :accessor previous-activation :initform 0))
  (:documentation "A single neuron ecapsulating a list of axons."))


(defun make-neuron ()
  "Constructs a neuron object. The list of connections is initialized to an empty list."
  (make-instance 'neuron))


(defclass axon ()
  ((terminal :type neuron :accessor terminal)
   (weight :type number :accessor weight :initform 0)
   (fired :type boolean :accessor fired :initform nil))
  (:documentation "A single axon encapsulating the neuron at which it terminates
    and the weight of the connection."))


(defun make-axon (terminal-n initial-w)
  "Constructs an axon object setting the terminal neuron and initial connection weight."
  (let ((new-axon (make-instance 'axon)))
    (setf (terminal new-axon) terminal-n)
    (setf (weight new-axon) initial-w)
    new-axon))


(defmethod activation ((n neuron))
  "An overridable activation method for a neuron. This default implementation uses a simple 
threshold value."
  (if (>= (activation-state n) 1.0)
      (mapcar (lambda (axon)
                (setf (fired axon) T))
              (outgoing-axons n)))
  (setf (previous-activation n) (activation-state n))
  (setf (activation-state n) 0)
  nil)


(defmethod learning ((n neuron) (a axon))
  (setf (weight a) (+ (learning-rate n) (weight a))))


(defmethod propagation ((n neuron))
  "An overridable propagation method for a neuron. This default implementation sums the weights of all 
  incoming axons and then invokes activation to determine if the given neuron fires."
  (mapcar (lambda (axon)
            (if (fired axon)
                (progn
                  (setf (activation-state n) (+ (activation-state n) (weight axon)))
                  (learning n axon))))
          (incoming-axons n))
  (activation n))


(defclass neural-layer () 
  ((neurons :type list :accessor neurons))
  (:documentation "Encapsulates a list of neurons N that could be used to represent a
conceptual layer in a feed-forward style network."))


(defun make-neural-layer ( size constructor )
  "Constructs a neural-layer object encapsulating a list of 'size' number of neurons. The second
  argument specifies the constructor function for the desired type of neuron."
  (let ((layer (make-instance 'neural-layer)))
    (labels ((add-neuron (lst n)
               (if (> n 0)
                   (add-neuron (cons (funcall constructor) lst) (- n 1))
                   lst)))
      (setf (neurons layer) (add-neuron '() size))
      layer)))


(defclass feedforward-nn ()
  ((input-layer :type neural-layer :accessor input-layer)
   (output-layer :type neural-layer :accessor output-layer)
   (representation :type list :accessor representation)
   (input-map :type function :accessor input-map)
   (output-map :type function :accessor output-map))
  (:documentation "Encapsulates the input and output layers of a FF NN. The representation slot
    defines the NN in terms of a list of layers, including hidden layers. The first element of this list
    should be eql to input-layer and the last element should be eql to output-layer."))


(defun make-feedforward-nn (in out rep imap omap)
  (let ((ff-nn (make-instance 'feedforward-nn)))
    (setf (input-layer ff-nn) in)
    (setf (output-layer ff-nn) out)
    (setf (representation ff-nn) rep)
    (setf (input-map ff-nn) imap)
    (setf (output-map ff-nn) omap)
    ff-nn))


(defun wire-feedforward (lst)
  "Accepts a list of neural-layers, representing the layers from input to output, and 
wires the layer axons to neurons in feedforward form. Returns nil."
  (if (> (length lst) 1)
      (flet ((wire (src-layer dest-layer)
               (mapcar (lambda (src-neuron) 
                         (mapcar (lambda (dest-neuron)
                                   (let ((new-axon (make-axon dest-neuron 0.1)))
                                   (setf (outgoing-axons src-neuron) 
                                         (cons new-axon (outgoing-axons src-neuron)))
                                   (setf (incoming-axons dest-neuron) 
                                         (cons new-axon (incoming-axons dest-neuron))))) 
                         dest-layer))
                       src-layer)))
        (wire (neurons (car lst)) (neurons (nth 1 lst)))
        (wire-feedforward (cdr lst)))
      nil))


(defmethod run-nn-pass ((nn-obj feedforward-nn))
  ""
  (flet ((propagate (layer)
           (mapcar #'propagation (neurons layer))))
    (funcall (input-map nn-obj) (input-layer nn-obj))
    (let ((nn (representation nn-obj)))
      (mapcar (lambda (e)
                (if (typep e 'list)
                    (mapcar #'propagate e)
                    (propagate e)))
              nn))
    (funcall (output-map nn-obj) (output-layer nn-obj))
    nil))

